home *** CD-ROM | disk | FTP | other *** search
/ Languguage OS 2 / Languguage OS II Version 10-94 (Knowledge Media)(1994).ISO / a_utils / ffccflow / ffccflow.lha / ffccc+flow / ffccc / SETTYP.f < prev    next >
Text File  |  1992-07-31  |  10KB  |  272 lines
  1.       SUBROUTINE SETTYP(MODE)   
  2. *-----------------------------------------------------------------------
  3. *   
  4. *   Sets variable types for a given statement, or updates default list  
  5. *   and names so far in case of IMPLICIT.   
  6. *   
  7. *   Only sensible if called for all statements in a routine, and while  
  8. *   establishing a name list for that routine.  
  9. *   
  10. *   Input   
  11. *   MODE      = 0 : reset default type table, no further action 
  12. *             > 0 : process statement   
  13. *   SSTA (statement), NSNAME, NRNAME etc.   
  14. *   Output  
  15. *   NAMTYP in common /STATE/
  16. *   
  17. *   Each type corresponds to a bit position (for testing use ITBIT).
  18. *   
  19. *   Types are:  
  20. *   
  21. *   Bit          meaning
  22. *   
  23. *     1          INTEGER
  24. *     2          REAL   
  25. *     3          LOGICAL
  26. *     4          COMPLEX
  27. *     5          DOUBLE PRECISION   
  28. *     6          CHARACTER  
  29. *     7          PARAMETER  
  30. *     8          COMMON block name  
  31. *     9          NAMELIST name  
  32. *    10          statement function 
  33. *    11          INTRINSIC  
  34. *    12          EXTERNAL   
  35. *    13          PROGRAM name   
  36. *    14          BLOCK DATA name
  37. *    15          SUBROUTINE 
  38. *    16          ENTRY  
  39. *    17          FUNCTION (intrinsic or external)   
  40. *    18          dimensioned
  41. *    19          (routine or function) argument 
  42. *    20          in a COMMON block  
  43. *    21          strongly typed function (internal usage)   
  44. *   
  45. *-----------------------------------------------------------------------
  46.       include 'PARAM.h' 
  47.       include 'ALCAZA.h' 
  48.       include 'CLASS.h' 
  49.       include 'FLWORK.h' 
  50.       include 'FLAGS.h' 
  51.       include 'CURSTA.h' 
  52.       include 'STATE.h' 
  53.       include 'TYPDEF.h' 
  54.       include 'CONDEC.h' 
  55.       CHARACTER STEMP*1 ,STEMP1*1   
  56.       LOGICAL RANGE 
  57.       DIMENSION ILOC(MCLASS),KDEFTP(26),NLIM1(2),NLIM2(2)   
  58. *--- KDEFTP = default FORTRAN types (REAL and INTEGER) for first letter 
  59. *    KILOC  = last location of ISTMDS not relevant for ILOC 
  60. *    ILOC   = local copy of type descriptors from ISTMDS
  61.       DATA KDEFTP/8*2,6*1,12*2/, KILOC/14/  
  62.       include 'CONDAT.h' 
  63.       IF(MODE.EQ.0)  THEN   
  64. *--- routine header: reset default type table   
  65.          DO 10 I=1,26   
  66.             KVTYPE(I)=KDEFTP(I) 
  67.    10    CONTINUE   
  68.          GOTO 999   
  69.       ENDIF 
  70.       DO 20 I=ISNAME+1,ISNAME+NSNAME
  71.          NAMTYP(I)=0
  72.    20 CONTINUE  
  73.       IF(ICURCL(1).EQ.IIF)  THEN
  74.          IUP=2  
  75. *--- find end of IF(...)
  76.          JPT=INDEX(SSTA(:NCHST),'(')
  77.          CALL SKIPLV(SSTA,JPT+1,NCHST,.FALSE.,KND,ILEV) 
  78.          NLIM1(1)=1 
  79.          DO 30 I=1,NSNAME   
  80.             IF(NSSTRT(I).GT.KND) GOTO 40
  81.    30    CONTINUE   
  82.          I=NSNAME+1 
  83.    40    CONTINUE   
  84.          NLIM2(1)=I-1   
  85.          NLIM1(2)=I 
  86.          NLIM2(2)=NSNAME
  87.       ELSE  
  88.          IUP=1  
  89.          KND=NCHST  
  90.          NLIM1(1)=1 
  91.          NLIM2(1)=NSNAME
  92.       ENDIF 
  93.       DO 120 IPART=1,IUP
  94.          IF (IPART.EQ.1)  THEN  
  95.             ICL=ICURCL(1)   
  96.             KST=1   
  97.          ELSE   
  98.             ICL=ICURCL(2)   
  99.             KST=KND+1   
  100.             KND=NCHST   
  101.          ENDIF  
  102. *--- get flags, counts, and types   
  103.          DO 50 I=1,MCLASS-KILOC 
  104.             ILOC(I)=ISTMDS(KILOC+I,ICL) 
  105.    50    CONTINUE   
  106.          IFLG2=ILOC(1)/10   
  107.          IFLG1=ILOC(1)-10*IFLG2 
  108.          ILPT=2 
  109.          IULOOP=1   
  110.          IF(IFLG2.NE.0) THEN
  111. *--- take only names outside brackets, get ranges for this  
  112.             CALL GETRNG(KST,KND,IWS)
  113.          ENDIF  
  114.          IF(IFLG2.EQ.2) THEN
  115. *--- treat COMMON block names specially 
  116.             IULOOP=2
  117.             ICOMMB=ILOC(ILPT+1) 
  118.             NLPT=ILOC(ILPT) 
  119.          ENDIF  
  120.          IF(IFLG1.EQ.0) THEN
  121. *--- treat all names the same   
  122.             ILOW=NLIM1(IPART)   
  123.             INUP=NLIM2(IPART)   
  124.             NLOOP=1 
  125.          ELSEIF(IFLG1.EQ.1) THEN
  126. *--- different types for first name, and rest   
  127.             NLOOP=2 
  128.          ELSE   
  129. *--- special treatment for IMPLICIT statement   
  130.             CALL SETIMP 
  131. *--- update the already existing names except strongly typed
  132.             DO 60 I=1,NRNAME
  133.                NT=NAMTYP(IRNAME+I)  
  134. *--- do not change type of strongly typed function, nor parameter   
  135.                IF (ITBIT(NT,7).EQ.0.AND.ITBIT(NT,21).EQ.0) THEN 
  136.                   K=ICVAL(SNAMES(IRNAME+I)(1:1))
  137.                   NT=NT-MOD(NT,64)  
  138.                   CALL ISBIT(NT,KVTYPE(K))  
  139.                   NAMTYP(IRNAME+I)=NT   
  140.                ENDIF
  141.    60       CONTINUE
  142.             GOTO 999
  143.          ENDIF  
  144. *--- the following IF(...) must stay here because of IMPLICIT   
  145.          IF (NSNAME.EQ.0.OR.ILOC(2).EQ.0) GOTO 999  
  146.          DO 110 ILOOP=IULOOP,NLOOP  
  147.             IF (IFLG1.NE.0) THEN
  148.                IF (ILOOP.EQ.1) THEN 
  149.                   ILOW=NLIM1(IPART) 
  150.                   INUP=NLIM1(IPART) 
  151.                ELSE 
  152.                   IF(IFLG2.EQ.2) THEN   
  153.                      ILOW=NLIM1(IPART)  
  154.                   ELSE  
  155.                      ILOW=NLIM1(IPART)+1
  156.                   ENDIF 
  157.                   INUP=NLIM2(IPART) 
  158.                   ILPT=ILPT+NLPT+1  
  159.                ENDIF
  160.             ENDIF   
  161.             NLPT=ILOC(ILPT) 
  162. *--- loop over names
  163.             DO 100 JN=ILOW,INUP 
  164.                IF (IFLG2.NE.0) THEN 
  165. *--- take only names outside brackets   
  166.                   IF (RANGE(NSSTRT(JN),IWS)) GOTO 100   
  167.                ENDIF
  168. *--- check whether already typed in this statement (except COMMON)  
  169.             IF(IFLG2.LT.2)  THEN
  170.                DO 70 JL=1,JN-1  
  171.                   IF (SNAMES(ISNAME+JL).EQ.SNAMES(ISNAME+JN)) THEN  
  172.                      NT=NAMTYP(ISNAME+JL)   
  173.                      IPOS=0 
  174.                      GOTO 90
  175.                   ENDIF 
  176.    70          CONTINUE 
  177.                ENDIF
  178. *--- check against existing routine name table  
  179.                CALL NAMSRC(SNAMES(ISNAME+JN),SNAMES(IRNAME+1),NRNAME,   
  180.      +         IPOS, LAST)  
  181.                IF (IPOS.EQ.0) THEN  
  182. *--- not yet in table   
  183.                   NT=0  
  184.                ELSE 
  185.                   NT=NAMTYP(IRNAME+IPOS)
  186.                ENDIF
  187.                IF(IFLG2.EQ.2) THEN  
  188. *--- common block   
  189. *--- look for common block name = /.../ 
  190.                      NFCB=NSSTRT(JN)-1  
  191.                      STEMP=SSTA(NFCB:NFCB)  
  192.                      IF(STEMP.EQ.' ') THEN  
  193.                         NFCB=NFCB-1 
  194.                         STEMP=SSTA(NFCB:NFCB)   
  195.                      ENDIF  
  196.                      IF(STEMP.EQ.'/') THEN  
  197.                         NSCB=NSEND(JN)+1
  198.                         IF(NSCB.LT.NCHST) THEN  
  199.                            STEMP=SSTA(NSCB:NSCB)
  200.                            IF(STEMP.EQ.' ') STEMP=SSTA(NSCB+1:NSCB+1)   
  201.                            IF(STEMP.EQ.'/') THEN
  202.                               NFCB=NFCB-1   
  203.                               STEMP1=SSTA(NFCB:NFCB)
  204.                               IF(STEMP1.EQ.' ') STEMP1=SSTA(NFCB-1:NFCB 
  205.      +                        -1)   
  206.                               JNL=MAX(JN-1,1)   
  207.                               IF((JN.EQ.1.OR.ITBIT(NAMTYP(ISNAME+JNL),  
  208.      +                        ICOMMB).EQ.0).AND.STEMP1.NE.'/') THEN 
  209.                                  NT=0   
  210.                                  CALL ISBIT(NT,ICOMMB)  
  211.                                  NAMTYP(ISNAME+JN)=NT   
  212.                                  GOTO 100   
  213.                               ENDIF 
  214.                            ENDIF
  215.                         ENDIF   
  216.                      ENDIF  
  217.                ENDIF
  218. *--- loop over types (for first, or second, or all) 
  219.                DO 80 JT=ILPT+1,ILPT+NLPT
  220.                   ITYP=ILOC(JT) 
  221.                   IF (ITYP.EQ.0) THEN   
  222. *--- skip if already typed (REAL, INTEGER, etc.)
  223.                      IF (MOD(NT,64).NE.0) GOTO 80   
  224. *--- skip if ENTRY in SUBROUTINE
  225.                      IF(STATUS(14).AND.ISTMDS(6,ICL).EQ.29) GOTO 80 
  226. *--- take default type  
  227.                      ITYP=KVTYPE(ICVAL(SNAMES(ISNAME+JN)(1:1)) )
  228.     
  229.                   ELSEIF (ITYP.LE.6) THEN   
  230. *--- strong typing - reset other types  
  231.                      NT=NT-MOD(NT,64)   
  232.                   ELSEIF (ITYP.EQ.10) THEN  
  233. *--- check for statement function declaration (not dimensioned) 
  234.                      IF (ITBIT(NT,18).NE.0) GOTO 80 
  235. *--- no':' allowed in bracket   
  236.                      JLB=INDEX(SSTA(KST:KND),'(')+KST-1 
  237.                      JRB=INDEX(SSTA(KST:KND),')')+KST-1 
  238.                      CALL POSCH(':',SSTA,JLB+1,JRB-1,.FALSE.,0,KPOS,
  239.      +               ILEV)  
  240.                      IF (KPOS.NE.0) GOTO 80 
  241.                   ELSEIF (ITYP.EQ.17.OR.ITYP.EQ.18) THEN
  242. *--- function (17) or array (18)
  243. *    get next non-blank behind name 
  244.                      IF (NSEND(JN).EQ.KND) GOTO 80  
  245.                      CALL GETNBL(SSTA(NSEND(JN)+1:KND),STEMP,NN)
  246.                      IF (NN.EQ.0.OR.STEMP.NE.'(')GOTO 80
  247.                      IF (ITYP.EQ.17) THEN   
  248. *--- only function if not dimensioned   
  249.                         IF (ITBIT(NT,18).NE.0) GOTO 80  
  250. *--- should not be statement function   
  251.                         IF (ITBIT(NT,10).NE.0) GOTO 80  
  252. *--- no ':' allowed on zero level in bracket following  
  253.                         JLB=NSEND(JN)+INDEX(SSTA(NSEND(JN)+1:KND),'(')  
  254.                         CALL SKIPLV(SSTA,JLB+1,KND,.FALSE.,JRB,ILEV)
  255.                         CALL POSCH(':',SSTA,JLB+1,JRB-1,.FALSE.,0,KPOS, 
  256.      +                  ILEV )  
  257.                         IF (KPOS.NE.0) GOTO 80  
  258.                      ENDIF  
  259.                   ENDIF 
  260. *--- type is accepted for this variable - set   
  261.                   CALL ISBIT(NT,ITYP)   
  262.    80          CONTINUE 
  263.    90          CONTINUE 
  264.                NAMTYP(ISNAME+JN)=NT 
  265.                IF (IPOS.GT.0) THEN  
  266.                   NAMTYP(IRNAME+IPOS)=NT
  267.                ENDIF
  268.   100       CONTINUE
  269.   110    CONTINUE   
  270.   120 CONTINUE  
  271.   999 END   
  272.